unit uSBD_ServiceProviderImpl;
interface
uses uSBD_ServiceProvider, Classes, Generics.Collections, Generics.Defaults;

type
RServiceKey = record
    FServiceIID: TGUID;
    FConfig: string;
    end;

RService = record
    FLiveService: IInterface;
    FFlyweightCreateBase: TClass;
    FFlyweightFactory: TServiceFactory;
    FCookie: Integer;
  end;

{$WARNINGS OFF}
TServiceProvider = class( TInterfacedObject, IServiceProvider, IEqualityComparer<RServiceKey>)
  strict private
    FisConstructing: boolean;

  private
    FServices: TDictionary<RServiceKey,RService>;

    function  RegisterLiveService   ( const ServiceIID: TGUID; const Service: IInterface; const Config: string): integer;
    function  RegisterFlyweightService( const ServiceIID: TGUID; CreateBase: TClass; Factory: TServiceFactory; const Config: string): integer;
    function  RegisterServiceClass( Registrant: TClass; const ServiceIID: TGUID): TList<integer>;
    procedure DeregisterService( RegistrationCookie: integer);
    function  Acquire( const Client: IInterface; const ServiceIID: TGUID; out Intf; const Config: string): boolean;
    function  Equals( const Left, Right: RServiceKey): Boolean;
    function  GetHashCode( const Value: RServiceKey): Integer;
    function  NextCookie: integer;
    function  FindKey( Cookie: Integer; out Key: RServiceKey): boolean;
    procedure ShutDown;

  public
    constructor Create;
    destructor  Destroy; override;
  end;
{$WARNINGS ON}

implementation





uses Rtti, SysUtils, TypInfo;

{ TServiceProvider }

constructor TServiceProvider.Create;
var
  Registrant: TPair<RServiceKey,RService>;
begin
FisConstructing := True;
FServices := TDictionary<RServiceKey,RService>.Create( Self);
RegisterFlyweightService( IServiceProvider, nil,
  function( Obj: TObject; const Config: string;
  const ServiceProvider: IServiceProvider): IInterface
    begin
    result := self as IServiceProvider
    end, '');
RegisterFlyweightService( IServiceProvider, nil,
  function( Obj: TObject; const Config: string;
  const ServiceProvider: IServiceProvider): IInterface
    begin
    result := TServiceProvider.Create as IServiceProvider
    end, 'New');
FisConstructing := False
end;

destructor TServiceProvider.Destroy;
begin
FServices.Free;
inherited
end;

type
TSuiteInjector = class;
IInjectableMember = interface
  ['{EB594A82-EAAE-4555-BAA0-33F86E6B5D8D}']
    function  IsInjectable: boolean;
    function  AsRttiMember: TRttiMember;
    function  MemberType: TRttiType;
    procedure SetValue( const Inject: TValue);
  end;

TInjectableMember = class( TInterfacedObject, IInjectableMember)
  protected
    FOwner: TSuiteInjector;

    function  IsInjectable: boolean;   virtual; abstract;
    function  AsRttiMember: TRttiMember;  virtual; abstract;
    function  MemberType: TRttiType;   virtual; abstract;
    procedure SetValue( const Inject: TValue);    virtual; abstract;
  public
    constructor Create( Owner1: TSuiteInjector);
  end;

ISuiteInjector = interface
  ['{72088119-43E6-4273-928B-0C84E0F84791}']
    procedure   Inject( const Provider: IServiceProvider);
  end;

TSuiteInjector = class( TInterfacedObject, ISuiteInjector)
  public
    FInjectionSubject: TObject;
    FServiceType : TRttiType;
    FClient: IInterface;
    FInjectionsClient: IInterface;

    constructor Create( InjectionSubject1: TObject;
                        ServiceType1 : TRttiType;
                        const Client1: IInterface);
    destructor  Destroy; override;
    procedure   Inject( const Provider: IServiceProvider);

  protected
    FMembers: TEnumerable<IInjectableMember>;
    function  GetMembers: TEnumerable<IInjectableMember>;   virtual; abstract;
  end;
TSuiteInjectorClass = class of TSuiteInjector;

TDataMemberInjector = class( TSuiteInjector)
  protected
    function  GetMembers: TEnumerable<IInjectableMember>;          override;
  end;

TWritablePropertyInjector = class( TSuiteInjector)
  protected
    function  GetMembers: TEnumerable<IInjectableMember>;          override;
  end;

TInjectableDataMember = class( TInjectableMember)
  private
    FMember: TRttiField;
  protected
    function  IsInjectable: boolean;              override;
    function  AsRttiMember: TRttiMember;          override;
    function  MemberType: TRttiType;              override;
    procedure SetValue( const Inject: TValue);    override;
  public
    constructor Create( Owner1: TSuiteInjector; Member1: TRttiField);
  end;

TInjectablePropMember = class( TInjectableMember)
  private
    FMember: TRttiProperty;
  protected
    function  IsInjectable: boolean;              override;
    function  AsRttiMember: TRttiMember;          override;
    function  MemberType: TRttiType;              override;
    procedure SetValue( const Inject: TValue);    override;
  public
    constructor Create( Owner1: TSuiteInjector; Member1: TRttiProperty);
  end;


TMemberEnumable<MemberT> = class( TEnumerable<IInjectableMember>)
  private
    FMembers: TArray<MemberT>;
    FSuite: TSuiteInjector;
  public
    constructor Create( Suite1: TSuiteInjector);     virtual;
  end;

TPropEnumerable = class( TMemberEnumable<TRttiProperty>)
  protected
    function DoGetEnumerator: TEnumerator<IInjectableMember>; override;
  private
    constructor Create( Suite1: TSuiteInjector);     override;
  end;

TFieldEnumerable = class( TMemberEnumable<TRttiField>)
  protected
    function DoGetEnumerator: TEnumerator<IInjectableMember>; override;
  private
    constructor Create( Suite1: TSuiteInjector);     override;
  end;

TMemberEnumator<MemberT> = class( TEnumerator<IInjectableMember>)
  protected
    FOwner: TMemberEnumable<MemberT>;
    FIndex: integer;
    function DoMoveNext: Boolean; override;
  public
    constructor Create( Owner1: TMemberEnumable<MemberT>);
  end;

TPropEnumator = class( TMemberEnumator<TRttiProperty>)
  protected
    function DoGetCurrent: IInjectableMember; override;
  public
    constructor Create( Owner1: TMemberEnumable<TRttiProperty>);
  end;

TFieldEnumator = class( TMemberEnumator<TRttiField>)
  protected
    function DoGetCurrent: IInjectableMember; override;
  public
    constructor Create( Owner1: TMemberEnumable<TRttiField>);
  end;

function TServiceProvider.Acquire(
  const Client: IInterface; const ServiceIID: TGUID;
  out Intf; const Config: string): boolean;
const
  Suites: array[0..1] of TSuiteInjectorClass = (TDataMemberInjector, TWritablePropertyInjector);
var
  Key: RServiceKey;
  Value: RService;
  Cls: TClass;
  Obj: TObject;
  Rtti: TRttiContext;
  ServiceType: TRttiType;
  Inject: IInterface;
  SuiteCls: TSuiteInjectorClass;
  Hold: IInterface;
begin
Key.FServiceIID := ServiceIID;
Key.FConfig     := Config;
result := FServices.TryGetValue( Key, Value);
if not result then exit;
IInterface( Intf) := Value.FLiveService;
if assigned( IInterface( Intf)) then exit;
Obj := nil;
try
  if assigned( Value.FFlyweightFactory) then
    begin
    Cls := Value.FFlyweightCreateBase;
    if assigned( Cls) then
        begin
        Obj  := Cls.NewInstance;
        Supports( Obj, IInterface, Hold);
        // ^-- Needed for reference counted objects which do not use
        //  the BeforeConstruction property to set the reference count
        //  to one.
        Rtti := TRttiContext.Create;
        ServiceType := Rtti.GetType( Cls);
        for SuiteCls in Suites do
          (SuiteCls.Create( Obj, ServiceType, Client) as ISuiteInjector)
            .Inject( self);
        Rtti.Free
        end
      else
        Obj := nil;
    IInterface( Intf) := Value.FFlyweightFactory( Obj, Config, Self);
    result := assigned( IInterface( Intf));
    Hold   := nil
    end
  else
    result := False
except
    begin
    Inject := nil;
    Obj.Free;
    raise
    end
  end
end;


function TServiceProvider.Equals(const Left, Right: RServiceKey): Boolean;
begin
Result := IsEqualGUID( Left.FServiceIID, Right.FServiceIID) and
          (Left.FConfig = Right.FConfig)
end;

function TServiceProvider.FindKey( Cookie: Integer; out Key: RServiceKey): boolean;
var
  Pair: TPair<RServiceKey,RService>;
begin
result := False;
for Pair in FServices do
  begin
  result := Pair.Value.FCookie = Cookie;
  if not result then continue;
  Key := Pair.Key;
  break
  end;
end;

function TServiceProvider.GetHashCode( const Value: RServiceKey): Integer;
var
  L: integer;
begin
result := BobJenkinsHash( Value.FServiceIID, SizeOf( Value.FServiceIID), 0);
L := Length( Value.FConfig);
if L > 0 then
  result := BobJenkinsHash( Value.FConfig[1], L * SizeOf( Value.FConfig[1]), result)
end;

function TServiceProvider.NextCookie: integer;
var
  Value: RService;
begin
result := -1;
for Value in FServices.Values do
  begin
  if Value.FCookie > result then
    result := Value.FCookie
  end;
Inc( result)
end;

function TServiceProvider.RegisterFlyweightService(const ServiceIID: TGUID;
  CreateBase: TClass; Factory: TServiceFactory; const Config: string): integer;
var
  Key: RServiceKey;
  Value: RService;
begin
Key.FServiceIID := ServiceIID;
Key.FConfig     := Config;
Value.FLiveService := nil;
Value.FFlyweightCreateBase := CreateBase;
Value.FFlyweightFactory := Factory;
if FisConstructing then
    result := -1
  else
    result := NextCookie;
Value.FCookie := result;
FServices.AddOrSetValue( Key, Value)
end;

function TServiceProvider.RegisterLiveService(const ServiceIID: TGUID;
  const Service: IInterface; const Config: string): integer;
var
  Key: RServiceKey;
  Value: RService;
begin
Key.FServiceIID := ServiceIID;
Key.FConfig     := Config;
Value.FLiveService := Service;
Value.FFlyweightCreateBase := nil;
Value.FFlyweightFactory := nil;
result := NextCookie;
Value.FCookie := result;
FServices.AddOrSetValue( Key, Value)
end;

function TServiceProvider.RegisterServiceClass(
  Registrant: TClass; const ServiceIID: TGUID): TList<integer>;
var
  Context: TRTTIContext;
  ServiceType: TRttiType;
  A: TCustomAttribute;
  M: TRttiMethod;
  ConfigAttrib: Configuration;
  j: integer;
  ConstructorParamCount: integer;
  Params: TArray<TRttiParameter>;
  Configs, Blacklist: TStrings;
  sConfig: string;

  function AnonRegister(
    const ServiceIID: TGUID; const Config: string;
    RegCls: TClass; ConstructorMethod: TRttiMethod): integer;
  type
    AnonRegister_ActRec = record
      FServiceIID: TGUID;
      FContext: TRttiContext;
      FConstructor: TRttiMethod;
      FCls: TClass;
      end;
  var
    Closure: AnonRegister_ActRec;
  begin
  Closure.FContext := TRttiContext.Create;
  Closure.FContext.GetType( TypeInfo( integer));
  Closure.FConstructor := ConstructorMethod;
  Closure.FCls         := RegCls;
  Closure.FServiceIID  := ServiceIID;
  result := RegisterFlyweightService(
    ServiceIID, Registrant,
    function( Obj: TObject; const Config: string;
              const ServiceProvider: IServiceProvider): IInterface
      begin
      if Length( Closure.FConstructor.GetParameters) = 0 then
        Closure.FConstructor.Invoke( Obj, [])
      else
        Closure.FConstructor.Invoke( Obj, [Config]);
      Obj.AfterConstruction;
      if not Supports( Obj, Closure.FServiceIID, result) then
        Obj.Free
      end,
    Config)
  end;

begin
result := TList<Integer>.Create;
if assigned( Registrant) and Supports( Registrant, ServiceIID) then
  begin
  Context := TRTTIContext.Create;
  Configs := TStringList.Create;
  Blacklist := TStringList.Create;
  ServiceType := Context.GetType( Registrant);
  for A in ServiceType.GetAttributes do
    if A is BlacklistConfigs then
      Blacklist.AddStrings( BlacklistConfigs(A).FConfigs);
  for M in ServiceType.GetMethods do
    begin
    if not M.IsConstructor then continue;
    ConstructorParamCount := -1;
    Params := M.GetParameters;
    if Length( Params) = 0 then
        ConstructorParamCount := 0
      else if (Length( Params) = 1) and
              (Params[0].ParamType.TypeKind = tkUString) and
              (Params[0].Flags = [pfConst]) then
        ConstructorParamCount := 1;
    if ConstructorParamCount = -1 then continue;
    for A in M.GetAttributes do
      begin
      if not (A is Configuration) then continue;
      ConfigAttrib := Configuration(A);
      for j := 0 to ConfigAttrib.FConfigs.Count - 1 do
        begin
        sConfig := ConfigAttrib.FConfigs[j];
        if (Configs  .IndexOf( sConfig) <> -1) or
           (Blacklist.IndexOf( sConfig) <> -1) then
        continue;
        Configs.Add( sConfig);
        result.Add( AnonRegister( ServiceIID, sConfig, Registrant, M))
        end
      end;
    end;
  Context.Free;
  Configs.Free;
  Blacklist.Free
  end;
if result.Count = 0 then
  raise Exception.CreateFmt( 'TServiceProvider.RegisterServiceClass - ' +
    '%s not validly decorated for registration.', [Registrant.ClassName]);
end;

procedure TServiceProvider.ShutDown;
begin
FServices.Clear
end;

procedure TServiceProvider.DeregisterService( RegistrationCookie: integer);
var
  Key: RServiceKey;
begin
if (RegistrationCookie <> -1) and FindKey( RegistrationCookie, Key) then
  FServices.Remove( Key)
end;


{ TSuiteInjector }

constructor TSuiteInjector.Create(
  InjectionSubject1: TObject; ServiceType1: TRttiType;
  const Client1: IInterface);
begin
FInjectionSubject := InjectionSubject1;
FServiceType      := ServiceType1;
FClient           := Client1;
Supports( FInjectionSubject, IInterface, FInjectionsClient)
end;


destructor TSuiteInjector.Destroy;
begin
FMembers.Free;
inherited
end;

procedure TSuiteInjector.Inject( const Provider: IServiceProvider);
var
  Member: IInjectableMember;
  isInjection: boolean;
  Attrib: TCustomAttribute;
  sInjectionConfig: string;
  Inject: IInterface;
  InjectAsRttiValue: TValue;
  MemberType1: TRttiType;
  doInject: boolean;
begin
for Member in GetMembers do
  begin
  MemberType1 := Member.MemberType;
  isInjection := False;
  sInjectionConfig := '';
  Inject := nil;
  for Attrib in Member.AsRttiMember.GetAttributes do
    begin
    isInjection := Attrib is Injection;
    if not isInjection then continue;
    sInjectionConfig := Injection(Attrib).FConfig;
    break
    end;
  doInject := False;
  if isInjection and
     (MemberType1.TypeKind = tkInterface) and
     (MemberType1 is TRttiInterfaceType) and
     Member.IsInjectable then
    begin
    if IsEqualGUID( TRttiInterfaceType( MemberType1).GUID, IInterface) and
       (sInjectionConfig = sClientRef) then
        begin
        Inject   := FClient;
        doInject := Assigned( Inject)
        end
      else
        doInject := Provider.Acquire(
          FInjectionsClient, TRttiInterfaceType( MemberType1).GUID, Inject,
          sInjectionConfig)
    end;
  if doInject then
    begin
    TValue.Make( @Inject, MemberType1.Handle, InjectAsRttiValue);
    Member.SetValue( InjectAsRttiValue)
    end
  end
end;

{ TDataMemberInjector }

function TDataMemberInjector.GetMembers: TEnumerable<IInjectableMember>;
begin
if not Assigned( FMembers) then
  FMembers := TFieldEnumerable.Create( self);
result := FMembers
end;


{ TWritablePropertyInjector }

function TWritablePropertyInjector.GetMembers: TEnumerable<IInjectableMember>;
begin
if not Assigned( FMembers) then
  FMembers := TPropEnumerable.Create( self);
result := FMembers
end;


{ TInjectableMember }

constructor TInjectableMember.Create( Owner1: TSuiteInjector);
begin
FOwner := Owner1
end;

{ TInjectableDataMember }

function TInjectableDataMember.AsRttiMember: TRttiMember;
begin
result := FMember
end;

constructor TInjectableDataMember.Create(
  Owner1: TSuiteInjector; Member1: TRttiField);
begin
inherited Create( Owner1);
FMember := Member1
end;


function TInjectableDataMember.IsInjectable: boolean;
begin
result := True
end;


function TInjectableDataMember.MemberType: TRttiType;
begin
result := FMember.FieldType
end;


procedure TInjectableDataMember.SetValue( const Inject: TValue);
begin
FMember.SetValue( FOwner.FInjectionSubject, Inject)
end;

{ TInjectablePropMember }

function TInjectablePropMember.AsRttiMember: TRttiMember;
begin
result := FMember
end;

constructor TInjectablePropMember.Create(
  Owner1: TSuiteInjector; Member1: TRttiProperty);
begin
inherited Create( Owner1);
FMember := Member1
end;

function TInjectablePropMember.IsInjectable: boolean;
begin
result := FMember.IsWritable and (FMember is TRttiInstanceProperty)
end;

function TInjectablePropMember.MemberType: TRttiType;
begin
result := FMember.PropertyType
end;

procedure TInjectablePropMember.SetValue( const Inject: TValue);
begin
FMember.SetValue( FOwner.FInjectionSubject, Inject)
end;

{ TMemberEnumable<MemberT> }

constructor TMemberEnumable<MemberT>.Create( Suite1: TSuiteInjector);
begin
FSuite := Suite1
end;

{ TPropEnumerable }

constructor TPropEnumerable.Create( Suite1: TSuiteInjector);
begin
inherited Create( Suite1);
FMembers := FSuite.FServiceType.GetProperties
end;

function TPropEnumerable.DoGetEnumerator: TEnumerator<IInjectableMember>;
begin
result := TPropEnumator.Create( self)
end;

{ TFieldEnumerable }

constructor TFieldEnumerable.Create( Suite1: TSuiteInjector);
begin
inherited Create( Suite1);
FMembers := FSuite.FServiceType.GetFields
end;

function TFieldEnumerable.DoGetEnumerator: TEnumerator<IInjectableMember>;
begin
result := TFieldEnumator.Create( self)
end;

{ TMemberEnumator<MemberT> }

constructor TMemberEnumator<MemberT>.Create( Owner1: TMemberEnumable<MemberT>);
begin
FOwner := Owner1;
FIndex := -1
end;

function TMemberEnumator<MemberT>.DoMoveNext: Boolean;
begin
result := FIndex < Length( FOwner.FMembers);
if not result then exit;
inc( FIndex);
result := FIndex < Length( FOwner.FMembers)
end;

{ TPropEnumator<MemberT> }

constructor TPropEnumator.Create( Owner1: TMemberEnumable<TRttiProperty>);
begin
inherited Create( Owner1)
end;

function TPropEnumator.DoGetCurrent: IInjectableMember;
begin
result := TInjectablePropMember.Create( FOwner.FSuite, FOwner.FMembers[FIndex])
end;

{ TFieldEnumator }

constructor TFieldEnumator.Create(Owner1: TMemberEnumable<TRttiField>);
begin
inherited Create( Owner1)
end;

function TFieldEnumator.DoGetCurrent: IInjectableMember;
begin
result := TInjectableDataMember.Create( FOwner.FSuite, FOwner.FMembers[FIndex])
end;

function StandardServiceProvider: IServiceProvider;
begin
result := TServiceProvider.Create
end;

end.
